home *** CD-ROM | disk | FTP | other *** search
/ Windows Expert / Windows Expert.iso / windownt / perlnt.zip / eg / status.cmd < prev   
OS/2 REXX Batch file  |  1993-07-25  |  2KB  |  139 lines
  1. @rem = '-*- Perl -*-';
  2. @rem = '
  3. @echo off
  4. perl -S %0.cmd %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. ';
  7.  
  8.  
  9. #
  10. # perl script to extract info from status.txt
  11. #
  12. #
  13. # options:
  14. #          -t : look for tested features
  15. #          -u : look for untested features
  16. #          -n : look for not yet implemented features
  17. #          -N : look for not applicable features
  18. #          -a : look for all features
  19. #          -p : print features 
  20. #
  21.  
  22. if ($#ARGV < 0) {
  23.     $opt_a = 1;
  24. }
  25. else {
  26.     require 'getopts.pl';
  27.     &Getopts('ptunNa');
  28. }
  29.  
  30. @allfea = ('Tested', 'Untested', 'NYI', 'N/A');
  31.  
  32. #
  33. # set up regex for searching
  34. #
  35.  
  36. if ($opt_a) {
  37.     $pattern = 'Tested|Untested|NYI|N/A';
  38.     $opt_t = $opt_u = $opt_n = $opt_N = 1;
  39.     @fea = ('Tested', 'Untested', 'NYI', 'N/A');
  40. }
  41. else {
  42.     if ($opt_t) {
  43.     $pattern = 'Tested';
  44.     push(@fea, 'Tested');
  45.     }
  46.     if ($opt_u) {
  47.     $pattern .= '|' if $pattern ne '';
  48.     $pattern .= 'Untested';
  49.     push(@fea, 'Untested');
  50.     }
  51.     if ($opt_n) {
  52.     $pattern .= '|' if $pattern ne '';
  53.     $pattern .= 'NYI';
  54.     push(@fea, 'NYI');
  55.     }
  56.     if ($opt_N) {
  57.     $pattern .= '|' if $pattern ne '';
  58.     $pattern .= 'N/A';
  59.     push (@fea, 'N/A');
  60.     }
  61. }
  62.  
  63. %features = ();
  64.  
  65. open (S, "nt/status.txt") || die "Can't open status.txt: $!\n";
  66.  
  67. #
  68. # skip everything up to the first form feed
  69. #
  70.  
  71. while (<S>) {
  72.     last if $_ eq "\f\n";
  73. }
  74.  
  75. &do_header;
  76. $count = 0;
  77. while (<S>) {
  78.     chop;
  79.     (&do_header, next) if $_ eq "\f";
  80.     split;
  81.     print "$_\n" if $opt_p && ($_[1] =~ /$pattern/o);
  82.     $features{$_[1]}++;
  83. }
  84. close S;
  85.  
  86. $total = 0;
  87.  
  88. format top = 
  89.  
  90.    Perl Feature Summary
  91. --------------------------
  92. .
  93.  
  94. format STDOUT = 
  95. @<<<<<<<< @###   @##.##%
  96. $type, $features{$type}, $per
  97. .
  98.  
  99. format totals = 
  100. --------------------------
  101. @<<<<<<<< @###   @##.##%
  102. "Total", $total, 100.00
  103. . 
  104.  
  105. #print "\n\nPerl Feature Summary\n--------------------\n";
  106.  
  107. foreach $type (@allfea) {
  108.     $total += $features{$type};
  109. }
  110.  
  111. $^ = top;
  112.  
  113. foreach $type (@fea) {
  114.     $per = $features{$type} / $total * 100;
  115.     write;
  116. }
  117.  
  118. $~ = totals;
  119. write;
  120.  
  121. #print "page: $%, len: $=, lines left: $-, form: $~ top: $^, formfeed: $^L\n";
  122. exit 0;
  123.  
  124. sub do_header {
  125.     local($a) = scalar(<S>);
  126.     local($b) = scalar(<S>);
  127.     local($c) = scalar(<S>);
  128.     print $a if $opt_p;
  129.     print $b if $opt_p;
  130. }
  131.  
  132. sub usage {
  133.     die "status [-ptunNa]\n";
  134. }
  135.  
  136. __END__
  137. :endofperl
  138.  
  139.